

;; Version 0.2

;; Jean-Marie Codol
;; 18-12-2006

;; releases notes :
;; ameliorer le setf,
;; cas sur une variable de l' environnement,car ,cdr ,et de get (pour la gestion du set-defun)
;; pas reussit a faire le setf generique




;; Version 0.1

;; Jean-Marie Codol
;; 14-12-2006

;; releases notes :
;; (meval '(meval (fibo 10) ()) ())




;; pour charger ce fichier dans clisp
;; (load "evaluateur-test.lisp")

;; on peut tester le defun
;; (meval '(defun plus2 (x) (+ 2 x)) ())
;; (meval '(plus2 10) ())
;;   => 12

;; lambda expressions
;; (meval '((lambda (x) (+ 2 x)) 10) ())
;; => 12



;; make-env
(defun make-env (lvar lparam env)
  (if (null lvar)
      ;; null variables
      (if (null lparam)
	  ;; null variables et valeurs
	  env
	;; null variables et not null valeurs
	(ERROR "LE NOMBRE DE VARIABLES EST SUPERIEUR AU NOMBRE DE PARAMETRES : MAKE ENV IMPOSSIBLE"  ))
    ;; not null variables
    (if (null lparam)
	;; not null variables et null lvaleurs
        (ERROR "LE NOMBRE DE VARIABLES EST INFERIEUR AU NOMBRE DE PARAMETRES : MAKE ENV IMPOSSIBLE"  )
      ;; not null variables et not null valeurs
      (make-env (cdr lvar)
			  (cdr lparam)
			  (cons (cons (car lvar) (car lparam)) env)))))



;; l'aide pour le let !!!
(defun make-env-let (expr env)
  (if (null expr)
      env
    (if (atom (car expr))
	(cons (cons (car expr) ()) (make-env-let (cdr expr) env))
      (cons (cons (caar expr) (meval (cadar expr) env)) (make-env-let (cdr expr) env)))))


;; remplace des valeurs qui sont old par new (avec setf)
;; enlever les commentaires dans la fonction
(defun displace (old new)
   (if (atom new)
       (setf new `(progn ,new)))
   (setf (car old) (car new))
   (setf (cdr old) (cdr new))
   old)


;; evalue les arguments

(defun meval-args (larg env)
  (if (null larg)
      ()
    (cons (meval (car larg) env)
	  (meval-args (cdr larg) env))))



;; evalue le corps
(defun meval-body (larg env)
  (if (null (cdr larg))
      (meval (car larg) env)
    (progn 
      (meval (car larg) env)
      (meval-body (cdr larg) env))))


;; meval une lambda expr
(defun meval-lambda (carexpr mevalargs env)
  (meval-body (cddr carexpr)
        (make-env (cadr carexpr) mevalargs env)))


;; set un defun
(defun set_defun (nom lambdaexpr)
  (setf (get nom :defun) lambdaexpr ))

;; get un defun
(defun get_defun (nom)
  (get nom :defun))



;; le defmacro
(defun set_macro (nom body)
  (setf(get nom :macro) body))

;; les macro
(defun get_macro (nom)
  (get nom :macro))



;; charger un fichier dans le meta-evaluateur .
(defun mload (nomfich)
  (let ((flux (open nomfich :direction :input)) (EOf (gensym)))
    (let ((r (read flux () EOF)))
      (loop until (eql r EOF) do (progn (meval r ())
                                              (setf r (read flux () EOF)))))))


;; evalue nimporte quoi

(defun meval (expr env)
  (cond


   ;; cas des constantes
   ((and (atom expr)(constantp expr))
    expr)


   ;; cas des variables
   ((atom expr)
    (let ((x (assoc expr env)))
      (if (atom x)
	  (error "meval : la variable ~s n est pas definie" expr)
	(cdr x))))


   ;; lambda expression
   ;; utiliser la fonction externe meval-lambda
   ((and (consp (car expr))(eq 'lambda (caar expr)))
    (meval-lambda (car expr)
		  (meval-args (cdr expr) env) env))


   
   ;; quote :
   ((eq (car expr) 'QUOTE)(cadr expr))


   ;; if :
   ((eq (car expr) 'IF)
    (if (meval (cadr expr) env)
	(meval (caddr expr) env)
      (meval (cadddr expr) env )))





   ;; le let
   ((eq (car expr) 'let)
    (meval-body (cddr expr)
		(make-env-let (cadr expr)  env)))


   ;; le setq
   ;((eq (car expr) 'setq)
   ;(setf (cdr (assoc (cadr expr) env)) (meval (caddr expr) env)))


   ;; le setf
   ;((eq (car expr) 'setf)
   ; (setf (cdr (assoc (cadr expr) env)) (meval (caddr expr) env)))


   ;; cas du setf et setq
   ((or (eq (car expr) 'setf)  (eq (car expr) 'setq))
    ;; on veut attribuer un set sur une variable de l environnement
    (if (symbolp (cadr expr))
        (let ((cell (assoc (cadr expr) env)))
          (if cell
              (setf (cdr cell)
                    (meval (caddr expr) env))
            (error "meval ~s ~s n'est pas dans l'environnement ~s " (car expr) (cadr expr) env )))
      ;; on veut attribuer un set a une expression (ex: (car liste1) )
      (cond (
	     ;; cas du cdr
	     (eql (caadr expr) 'cdr)
             (setf (cdr (meval (cadadr expr) env))
                   (meval (caddr expr) env)))
	    ;; cas du car
            ((eql (caadr expr) 'car)
	     (setf (car (meval (cadadr expr) env))
                   (meval (caddr expr) env)))
	    ;; cas du get
            ((eql (caadr expr) 'get)
	     (setf (get (meval (cadadr expr) env) (meval (car (cddadr expr)) env))
                   (meval (caddr expr) env)))
            (t (error "setf : NYI ~s " expr ))
	    )))
   
   


    ;; cas des fonctions meta definies
    ;; defun
   ((eq (car expr) 'defun)
    (set_defun (cadr expr) `(lambda ,@(cddr expr))))

   ;; cas des macro meta-definies
   ((eq (car expr) 'defmacro)
    (set_macro (cadr expr) `(lambda ,@(cddr expr))))



   ;; une macro definie dans le meta evaluateur
   ;; faut il evaluer les arguments ??? 
   ((get_macro (car expr))
    (meval (displace expr 
		     (meval-lambda (get_macro (car expr))
				   (cdr expr) ())) env))
   


   ;; cas des macro du systeme
   ((macro-function (car expr)) ; macro connue par eval
   (meval (displace expr (macroexpand-1  expr)) env))



   ;; cas du progn
   ((eq (car expr) 'PROGN)
    (meval-body (cdr expr) env))


    ;; une fonction definie dans le meta evaluateur
   ((get_defun (car expr))
    (meval-lambda (get_defun (car expr))
		  (meval-args (cdr expr) env)
		  () ))




   ;; est une forme speciale
   ((special-form-p (car expr))
    (error "MEVAL : NYI ~S" expr))

   ;; la fonction doit etre definie sinon sortir proprement
   ((not (fboundp (car expr)))
    (error "MEVAL : La fonction ~S n'est pas definie (dans clisp)" (car expr)))



   ;; fonctions predefinies obligatoirement
   ;; final
   (t
    (apply (symbol-function (car expr))
	   (meval-args(cdr expr) env)))
;





   ); fin du cond


)








;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;

; utile sur les tests

; calcule la somme de fibonacci
; u(0) = u(1) = 1
; u ( n ) = u (n-1) + u (n-2)
;( defun fibo (x)
;     ( if (<= x 1)
;          1
;          (+ (fibo (- x 1) ) (fibo (- x 2)))
;     )
;)

;( defun fibo (x)
;     ( if (or (= x 1) (= x 0))
;          1
;          (+ (fibo (- x 1) ) (fibo (- x 2)))
;     )
;)








;; tests

;; 13 11
;(meval '((lambda (x)  y) 4) '((y . 3)))
;3

;(meval '(defun fibo (x) (if (<= x 1) 1 (+ (fibo (- X 1)) (FIBO (- X 2))))) () )
;(meval '(fibo 4 ) ())
;5


; cond ne marche pas !!!!!!!!!!!!****************
